perm filename TVFONT[1,BGB] blob
sn#026236 filedate 1973-02-23 generic text, type T, neo UTF8
00100 TITLE TVFONT - TELEVISION TO FONT - BGB - JANUARY 1973.
00200
00300 ;CONTROL FLAGS.
00400 INTERN FLGSIX,FLGARC,FLGBK
00500
00600 FLGKRK:0 ;ENABLE KRAKAUER TREE.
00700 FLGSIX:-1 ;SIX BIT TELEVISON.
00800 FLGARC:0 ;ENABLE MAKE ARC SMOOTHING.
00900
01000 FLGBK:0 ;ENABLE BABY KILLER.
01100 VCUT:-14 ;VECTOR DISPLAY CONTRAST THRESHOLD.
01200 FLGWED:0 ;DISPLAY WINGED EDGED IMAGE.
01300
01400 FLGBGB:0 ;RUNNING UNDER A BGB PPPN.
01500 FLGRAR:0 ;DISPLAY RECIPROCAL ARC RADIALS.
01600 ;-1 BOTH, 0 VIC, +1 ARCS.
01700 FLGKINK:0 ;DISPLAY KINKS.
01800 FLGU:-1 ;KILVIC ENABLE.
01900
02000 EXTERN REGION,MKFONT
00100 ;CAREYE STANDARD TV FILE IS =10496 WORDS LONG, 24400 OCTAL.
00200 ;=10 WORD HEADER, =216 ROWS OF =288 COLUMNS OF 6 BITS PER PIXEL.
00300 ;=118 WORD TRAILER.
00400
00500 HI ←← 400000
00600 $←400000
00700
00800 PAC ← HI ↔ HI ←← HI + =1728 ;PICTURE ACCUMULATOR.
00900 VSEG← HI ↔ HI ←← HI + =1729 ;VERTICAL SEGMENTS.
01000 HSEG← HI ↔ HI ←← HI + =1736 ;HORIZONTAL SEGMENTS.
01100
01200 HI ←← HI + =86 ;NEGATIVE ROWS.
01300 HEADER←HI ↔ HI ←← HI + =10
01400 TVBUF ←HI ↔ HI ←← HI + =10368 ;TV BUFFER 6 BITS PER PIXEL.
01500 HI ←← HI + =54 ;FREE SPACE.
01600 HISTO ←HI ↔ HI ←← HI + =64 ;HISTOGRAM.
01700 FTVSIX←HI ↔ HI ←← HI + 1 ;FLAG TV SIX BIT.
01800 FTVHIS←HI ↔ HI ←← HI + 1 ;FLAG TV HISTOGRAM PRESENT.
01900
02000
02100 ;POINTERS TO TV SEGMENT.
02200 TV: 0
02300 POINT 6,-1,29 ;COLUMN -2.
02400 POINT 6,-1,35 ;COLUMN -1.
02500 COLPTR: FOR I←0,=48{
02600 I+<POINT 6,0,05>↔I+<POINT 6,0,11>↔I+<POINT 6,0,17>
02700 I+<POINT 6,0,23>↔I+<POINT 6,0,29>↔I+<POINT 6,0,35>}
02800 ROWPTR: FOR I←0,=216{
02900 I*=48+TVBUF}
03000 ISAVED: 0
03100
03200 TVSEG: 0
03300 O(ATTSEG,CALLI 400016)
03400 O(DETSEG,CALLI 400017)
03500 O(SEGNUM,CALLI 400021)
03600 O(CORE2, CALLI 400015)
00100 ;INITIALIZATION---------------------------------------------------
00200 OPDEF PPIOT[702B8]
00300 PDL: BLOCK 100
00400
00500 ;START ADDRESS
00600 SA:
00650 LAC 17,[IOWD 100,PDL]
00700 CALL(MORCOR)
00800
00900 ;RE-ENTRY ADDRESS.
01000 REE: LACI .↔DAC 124
01100 PPIOT 2,-=250↔PPIOT 3,3003
01200 MOVEI 20↔CRLF↔SOJG .-1
01300 SETZ↔CALLI 24↔CDR
01400 CAIN'BGB'↔SETOM FLGBGB
01410 SKIPN FLGBGB↔GO[OUTSTR[ASCIZ/ TELEVISION FONT INPUT
01455 IS NOT A PUBLIC PROGRAM, YOU ARE NOT AN AUTHORIZED USER.
01456 /]↔CALLI 12↔]
01500 LAC 17,[IOWD 100,PDL]
01600 CALL(CROP)
01700 CALL(DPYIMG)
01800 PUSHJ TTY
01900 CALLI 12
02000 ;6/12/72----------------------------------------------------------
02100 ;TELETYPE COMMAND STATE.
02200 DECLARE{CTRL,META,CHR}
02300 INTERN CTRL,META
00100 SUBR(TTY)---------------------------------------------------------
00200 BEGIN TTY;CAREYE TELETYPE COMMAND JUMP TABLE -BGB- NOVEMBER 1972.
00300 L0: CRLF
00400 L1: OUTCHR["*"]
00500 INCHRW
00600 SETZM CTRL↔TRZE 200↔SETOM CTRL
00700 SETZM META↔TRZE 400↔SETOM META
00800 CAIN 0,15↔GO L1+1
00900 CAIN 0,12↔GO L1
01000 DAC 0,CHR
01100
01200 ;TEST FOR LETTER COMMAND.
01300 LAC 1,0↔ANDI 1,37
01400 CAIGE 0,"A"↔GO .+3
01500 CAIG 0,"Z"↔GO L3
01600 CAIGE 0,"a"↔GO .+3
01700 CAIG 0,"z"↔GO L3
01800
01900 ;WINDOW MOVING COMMANDS.
02000 CAIN 0," "↔GO L2
02100 CAIN 0,":"↔GO[LAC SX↔FAD DEL↔DAC SX↔GO L2]
02200 CAIN 0,";"↔GO[LAC SX↔FSB DEL↔DAC SX↔GO L2]
02300 CAIN 0,")"↔GO[LAC SY↔FAD DEL↔DAC SY↔GO L2]
02400 CAIN 0,"("↔GO[LAC SY↔FSB DEL↔DAC SY↔GO L2]
02500 CAIN 0,"/"↔GO[LAC DEL↔FSC -1↔DAC DEL↔GO L2]
02600 CAIN 0,"\"↔GO[LAC DEL↔FSC 1↔DAC DEL↔GO L2]
02700 CAIN 0,"*"↔GO[LAC MAG↔FMP[1.5]↔DAC MAG↔GO L2]
02800 CAIN 0,"-"↔GO[LAC MAG↔FDV[1.5]↔DAC MAG↔GO L2]
02900
03000 ;QBLK CHANGING COMMANDS.
03100 CAIN 0,"!"↔GO[SETZ 1,↔GO L2B+1]
03200 CAIN 0,"+"↔GO[LAC 1,FILM↔GO L2B+1]
03300 CAIN 0,","↔GO[SKIPE 1,QBLK↔CW 1,1↔GO L2B]
03400 CAIN 0,"."↔GO[SKIPE 1,QBLK↔CCW 1,1↔GO L2B]
03500 CAIN 0,"↓"↔GO[SKIPE 1,QBLK↔ENDO 1,1↔GO L2B]
03600 CAIN 0,"↑"↔GO[SKIPE 1,QBLK↔EXO 1,1↔GO L2B]
03700 CAIN 0,"↔"↔GO[SKIPE 1,QBLK↔ARC 1,1↔GO L2B]
03800 CAIN 0,"≥"↔GO[SKIPE 1,QBLK↔PED 1,1↔GO L2B]
03900 CAIN 0,"≤"↔GO[SKIPE 1,QBLK↔NED 1,1↔GO L2B]
04000 CAIN 0,"<"↔GO[SKIPE 1,QBLK↔NCCW 1,1↔GO L2B]
04100 CAIN 0,">"↔GO[SKIPE 1,QBLK↔SON 1,1↔GO L2B]
04200 CAIN 0,"→"↔GO[SKIPE 1,QBLK↔PGON 1,1↔GO L2B]
04300 CAIN 0,"←"↔GO[SKIPE 1,QBLK↔NGON 1,1↔GO L2B]
04400 CAIN 0,"6"↔GO[SETOM FLGSIX↔SETOM FTVSIX↔GO L1]
04500 CAIN 0,"4"↔GO[SETZM FLGSIX↔SETZM FTVSIX↔GO L1]
04600 GO L0
04700
04800 L2: CALL(CROP)↔CALL(DPYIMG)↔GO L1+1
04900 L2B: SKIPE 1↔DAC 1,QBLK↔CALL(DPYBLK)↔GO L1+1
00100
00200 L3: PUSHJ P,@L4(1)↔GO L1
00300
00400 L4: NOP ;null.
00500 ASCODE ;"A" ASSIGN ASCII CODE TO IMAGE.
00600 SCALED ;"B"
00700 MAKCUT ;"C" MAKE THRESHOLD CUT.
00800 FLGB. ;"D" DELETE BABY POLYGONS.
00900 NOP ;"E"
01000 NOP ;"F"
01100 NOP ;"G"
01200 DPYHIS ;"H" HISTOGRAM, "αH" ,"βH" BI-MODAL CUT.
01300 CREIN ;"I" INPUT TV PICTURE FROM DISK.
01400 NOP ;"J" ;JUSTIFY MODE.
01500 KLPOLY ;"K" KILL QBLK POLYGON.
01600 DPYPAK ;"L"
01700 MKGLYPH ;"M" MOVE POLYGON TO NEXT IMAGE.
01800 NEXIMG ;"N" IMAGE RETREAT.
01900 CREOUT ;"O" OUTPUT CAREYE FILE.
02000 PLOTO ;"P" PLOT OUTPUT FILE.
02100 MKFONT ;"Q"
02200 REGION ;"R"
02300 CAMERA ;"S" SELECT CAMERA, "αS" BCLIP, "βS" TCLIP.
02400 TVCAMI ;"T" TAKE TELEVISON PICTURE. "αT" SIXBIT.
02500 NOP ;"U"
02600 NOP ;"V"
02700 ADJUST ;"W" CENTER IN THE WINDOW.
02800 TVXGP ;"X" XEROX OUTPUT.
02900 FLGR. ;"Y" DISPLAY RECIPROCAL ARC RADIALS.
03000 KILLER ;"Z" ZERO DATA BUFFERS.
03100
03200 NOP: CRLF
03300 POP0J
03400 FLGB.: SETCMM FLGBK ↔CRLF↔POP0J
03500 FLGR.: SETZM FLGWED
03600 LAC CTRL↔AND META
03700 JUMPN[SETOM FLGKINK↔GO .+8]↔SETZM FLGKINK
03800 LACI 1↔DAC FLGRAR
03900 SKIPE CTRL↔SETOM FLGRAR
04000 SKIPE META↔SETZM FLGRAR
04100 CALL(DPYIMG)↔CRLF↔POP0J
04200 LIT
04300 BEND;12/8/72------------------------------------------------------
00100 SUBR(SEGTV)-------------------------------------------------------
00200 ;GET THE OLD TVSEG.
00300 SETZ↔SEGNUM
00400 SKIPE 1,TVSEG
00500 GO[ CAMN 0,1↔POP0J↔SKIPE↔DETSEG
00600 ATTSEG 1,↔GO[FATAL(TVSEG ATTACH FAILURE.)]↔POP0J]
00700 SKIPE↔DETSEG
00800 ;MAKE A NEW TVSEG.
00900 LACI HI
01000 CALLI 400015↔GO[FATAL(AIN'T NO CORE UP YONDER.)]
01100 LAC[SIXBIT/TVSEG/]↔CALLI 400036↔JFCL
01200 SETZ↔SEGNUM↔DAC TVSEG
01300 LAC[XWD $,$+1]↔SETZM $↔BLT HI-1
01400 LAC[XWD HEAD,HEADER]↔BLT HEADER+9
01500 POP0J
01600 ;OLDE TEN WORD TV PICTURE HEADER.
01700 HEAD: 7↔0↔6↔=288↔=48↔=20↔=235↔=28↔=315↔=10368
01800 ;16/12/72---------------------------------------------------------
00100 SUBR(KILLER)------------------------------------------------------
00200 BEGIN KILLER
00300 SKIPE CTRL↔GO L
00400 SETZM QBLK
00500 LAC OLD44↔CALLI 11↔JFCL↔SETZM OLD44
00600 SETZM AVAIL↔SETZM BLKCNT↔SETZM FILM
00700 CALL(MORCOR)
00800 L: SETZM SX↔SETZM SY↔LAC[32.0]↔DAC DEL↔LAC[3.4]↔DAC MAG
00900 CALL(CROP)↔CALL(DPYIMG)
01000 CRLF↔POP0J
01100 BEND;12/31/72-----------------------------------------------------
01200
01300 SUBR(NEXIMG)------------------------------------------------------
01400 BEGIN NEXIMG;NEXT IMAGE - BGB - 11 DEC 72.
01500 SKIPA
01600 SETOM CTRL
01700 LAC 1,FILM
01800 SON 2,1
01900 CDR 3,(2)↔SKIPE CTRL↔CAR 3,(2)
02000 SON. 3,1
02100 CALL(DPYIMG)
02200 SKIPE META↔GO[INCHRS↔GO NEXIMG↔GO .+1]
02300 CRLF
02400 POP0J
02500 BEND;12/11/72-----------------------------------------------------
00100 SUBR(MAKCUT)------------------------------------------------------
00200 BEGIN MAKCUT; MAKE CUTS "C" COMMAND.
00300
00400 ;CONTRAST DISPLAY CUT OFF COMMANDS.
00500 SKIPE META↔GO[MOVNS VCUT↔CALL(DPYIMG)↔POP0J]
00600 SKIPE CTRL↔GO[INCHRW↔ANDI 7↔LSH 3
00700 INCHRW 1↔ANDI 1,7↔IOR 0,1↔DAC VCUT↔CALL(DPYIMG)↔POP0J]
00800
00900 ;MAKE CUT COMMAND BEGINS HERE.
01000 SETZM QQ2↔SETZM QQ3
01100 L1: SETZ 1,↔INCHWL
01200 CAIN 15↔GO[CALL(L3)↔GO L2]
01300 CAIL 0,"0"↔CAILE 0,"7"↔GO[CALL(L3)↔GO L1]
01400 IMULI 1,=8↔ANDI 17↔ADD 1,0↔GO L1+1
01500
01600 L2: INCHWL
01700 CALL(CRE,QQ2,QQ3)↔CALL(DPYIMG)↔CALL(SHRINK)
01800 POP0J
01900
02000 DECLARE{QQ2,QQ3}
02100
02200 L3: SKIPN 1↔POP0J
02300 CAIL 1,=64↔POP0J
02400 MOVNS 1↔SETZ 3,
02500 SLACI 2,1B18↔LSHC 2,(1)
02600 IORM 2,QQ2↔IORM 3,QQ3
02700 POP0J
02800
02900 LIT
03000 BEND;1/17/73------------------------------------------------------
03100
00100 SUBR(REALIN)------------------------------------------------------
00200 BEGIN REALIN; INPUT FROM TTY SMALL REAL NUMBER - BGB - 16 DEC 1972.
00300 ;AC-0 INTEGER ACCUMULATION. AC-0 RETURNS REAL NUMBER.
00400 ;AC-1 CHARACTER. AC-1 RETURNS BREAK CHARACTER.
00500 ;AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
00600 ;AC-3 MINUS SIGN FLAG.
00700 SETZ↔SETZB 2,3
00800 L1: INCHWL 1
00900 CAIE 1,"-"↔GO .+3↔SETCMM 3↔GO L1
01000 CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
01100 CAIL 1,"0"↔CAILE 1,"9"↔GO L2
01200 JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
01300 ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
01400 L2: FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
01500 SKIPE 3↔MOVNS↔POP0J
01600 BEND;12/16/72-----------------------------------------------------
00100 SUBR(BABYKILLER)LEVEL---------------------------------------------
00200 BEGIN BABYKILLER; -BGB- 28 DEC 1972.
00300 ACCUMULATORS{A,PG,E0,E1,E2,Q,R}
00400 SKIPN FLGBK↔POP1J
00500 LAC 1,ARG1↔SON PG,1↔DAC PG,PG0#
00600 ;KLUDGE - SPARE SON POLYGON UNTIL WE CAN THINK OF A POLICY.
00700 GO L3
00800 ;ELIMINATE INSIGNIFICANT CONTOURS - SMALL LOW CONTRAST.
00900 L1: NCNT 0,PG↔LACM
01000 CAIL =10↔GO L3
01100
01200 ;RELEASE VIC NODES OF THE POLYGON.
01300 SON E0,PG
01400 LAC E1,E0
01500 L2: CCW E2,E1
01600 CALL(KILL,E1)
01700 CAMN E2,E0↔GO .+3
01800 LAC E1,E2↔GO L2
01900
02000 ;KILL A BABY POLYGON.
02100 CAR Q,(PG)↔CDR R,(PG)
02200 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02300 CALL(KILL,PG)
02400 SKIPA PG,R ;CCW FROM OUT OF THE GRAVE.
02500
02600 ;ADVANCE TO NEXT POLYGON ON THIS LEVEL.
02700 L3: CCW PG,PG↔CAME PG,PG0↔GO L1
02800 POP1J
02900
03000 BEND;1/6/73------------------------------------------------------
00100 SUBR(KLPOLY)------------------------------------------------------
00200 BEGIN KLPOLY;KILL POLYGON RETURN CCW(PGN) - BGB - 7 JANUARY 1973.
00300 ACCUMULATORS{PG,E0,E1,E2,Q,R}
00400 LAC PG,QBLK↔TEST PG,PBIT↔POP0J
00500
00600 ;RELEASE VIC NODES OF THE POLYGON.
00700
00800 SON E0,PG
00900 LAC E1,E0
01000 L1: CCW E2,E1
01100 CALL(KILL,E1)
01200 CAMN E2,E0↔GO .+3
01300 LAC E1,E2↔GO L1
01400
01500 ;RING OUT & KILL POLYGON NODE,
01600
01700 NGON Q,PG↔PGON R,PG↔JUMPE R,L2
01800 NGON. Q,R↔PGON. R,Q↔CAMN PG,R↔SETZ R,
01900 EXO 1,PG↔JUMPE 1,.+4↔ENDO 0,1↔CAMN 0,PG↔ENDO. R,1
01910 ENDO 1,PG↔SKIPE 1↔ZIP 3(1) ;MY ENDO BECOMES AN ORPHAN.
02000
02100 L2: CAR Q,(PG)↔CDR R,(PG)
02200 DIP Q,(R)↔ DAP R,(Q) ;RINGO PG.
02300 CALL(KILL,PG)
02400
02500 ;DOES DAD NEED A NEW FIRST SON.
02600
02700 DAD 1,R
02800 CAMN PG,R↔SETZ R,
02900 SON 0,1↔CAMN 0,PG↔SON. R,1
03000
03100 ;RETURN PGON CCW FROM OUT OF THE GRAVE.
03200 LAC 1,R↔DAC 1,QBLK↔CALL(DPYIMG)
03300 POP0J
03400
03500 BEND;1/8/73------------------------------------------------------
00100 SUBR(SQRT)--------------------------------------------------------
00200 BEGIN SQRT;MODIFIED OLDE LIB40 SQUARE ROOT - BGB - TRADITIONAL.
00300 A←0 ↔ B←1 ↔ C←2
00400 LACM B,ARG1↔JUMPE B,POP1J.↔PUSH P,2
00500
00600 ;LET X=F*(2↑2B) WHERE 0.25<F<1.00 THEN SQRT(X)=SQRT(F)*(2↑B).
00700 ASHC B,-=27↔SUBI B,201 ;GET EXPONENT IN B, FRACTION IN C.
00800 ROT B,-1 ;CUT EXP IN HALF, SAVE ODD BIT
00900 DAP B,L↔LSH B,-=35 ;USE THAT ODD BIT.
01000 ASH C,-10↔FSC C,177(B) ;0.25 < FRACTION < 1.00
01100
01200 ;LINEAR APPROXIMATION TO SQRT(F).
01300 DAC C,A
01400 FMP C,[0.8125↔0.578125](B)
01500 FAD C,[0.302734↔0.421875](B)
01600
01700 ;TWO ITERATIONS OF NEWTON'S METHOD.
01800 LAC B,A
01900 FDV B,C↔FAD C,B↔FSC C,-1
02000 FDV A,C↔FADR A,C
02100 L: FSC A,0↔LAC 1,A↔POP P,2
02200 POP1J↔LIT
02300 BEND;28/12/72-----------------------------------------------------
00100 SUBR(MKGLYPH)-----------------------------------------------------
00200 BEGIN; MAKE GLYPH IMAGE.
00300
00400 ACCUMULATORS{A2,PG,LVL,IMG}
00500 LAC PG,QBLK
00600 TEST PG,PBIT
00700 POP0J ;AIN'T POLYGON.
00800
00900 ;DETACH QBLK POLYGON FROM ITS LEVEL.
01000
01100 CW 1,PG↔CCW 2,PG↔DAC 2,PGSAV#
01200 CCW. 2,1↔CW. 1,2
01300 CAMN 1,PG↔SETZ 1,
01400 DAD LVL,PG↔SON 0,LVL
01500 CAMN 0,PG↔SON. 1,LVL
01600
01700 ;GET PREVIOUS IMAGE.
01800 LAC 1,FILM↔SON IMG,1↔DAC IMG,SAVIMG#
01900 CW IMG,IMG
02000 SON LVL,IMG
02100 SKIPN CTRL↔GO L1
02200
02300 ;MAKE NEW IMAGE WHEN CALLED FOR "αM".
02400 SETQ(I,{MKIMAG,FILM})
02500 SETQ(LVL,{MKLEVL,I,[-1]})
02600 LAC IMG,I#
02700 SON. LVL,IMG
02800 LAC PG,QBLK
02900
03000 ;PLACE THE POLYGON INTO THE IMAGE.
03100 L1: CALL(RINGIN,PG,LVL)
03200 LAC 1,FILM↔LAC SAVIMG↔SON. 0,1
03300 LAC PGSAV↔DAC QBLK
03400 CALL(DPYIMG)
03500 CRLF
03600 POP0J
03700 BEND;1/28/73------------------------------------------------------
00001 SUBR(ASCODE)------------------------------------------------------
00002 BEGIN ASCODE; ASSIGN ASCII CODE TO IMAGE.
00003 LAC 1,FILM↔SON 1,1↔SKIPN 1↔POP0J ;IMAGE
00004 SON 1,1↔SKIPN 1↔POP0J ;LEVEL
00005 OUTSTR[ASCIZ/ CHARACTER = /]
00006 INCHRW↔DAP 0,4(1)
00007 CALL(DPYIMG)
00008 CRLF
00009 BEND;2/1/73-------------------------------------------------------
00010
00011
00100 SUBR(ADJUST)------------------------------------------------------
00200 BEGIN ADJUST;ADJUST CHARACTER LOCUS TO CENTER OF IMAGE.
00300
00400 ACCUMULATORS{IMG,LVL,PGN,V,R,C}
00500
00600 SKIPN 1,FILM↔POP0J
00700 SON IMG,1↔SKIPN IMG↔POP0J
00800 DAC IMG,IMG0# ;FIRST IMAGE OF FILM
00900 L2: SON LVL,IMG
01000 SON PGN,LVL↔DAC PGN,PGN0# ;FIRST POLYGON OF IMAGE.
01100
01200 ;FIND LOWERMOST AND LEFTMOST VERTICES OF THE IMAGE.
01300 SETZM RMAX#↔LACI =288⊗6↔DAC CMIN#
01400 L3: SON V,PGN
01500 DAC V,V0# ;FIRST VECTOR OF THIS POLYGON.
01600
01700 L4: ROW R,V↔CAML R,RMAX↔DAC R,RMAX
01800 COL C,V↔CAMG C,CMIN↔DAC C,CMIN
01900 CCW V,V↔CAME V,V0↔GO L4
02000 CCW PGN,PGN↔CAME PGN,PGN0↔GO L3
02100
02200 ;RELOCATE IMAGE.
02300 LAC RMAX↔ADDI 40↔ANDCMI 77↔SUBI =108⊗6↔DACN RMAX
02400 LAC CMIN↔ADDI 40↔ANDCMI 77↔SUBI =144⊗6↔DACN CMIN
02500 L5: SON V,PGN↔DAC V,V0
02600 L6: ROW R,V↔ADD R,RMAX↔ROW. R,V
02700 COL C,V↔ADD C,CMIN↔COL. C,V
02800 CCW V,V↔CAME V,V0↔GO L6
02900 CCW PGN,PGN↔CAME PGN,PGN0↔GO L5
03000 ;NEXT IMAGE.
03100 CCW IMG,IMG↔CAME IMG,IMG0↔GO L2
03200 CALL(DPYIMG)
03300 POP0J
03400 BEND;1/28/73------------------------------------------------------
00100 SUBR(SCALED)------------------------------------------------------
00200 BEGIN SCALED;CHANGE SCALE OF ALL IMAGES.
00300
00400 ACCUMULATORS{IMG,LVL,PGN,V,R,C,K1,K2,SLANT}
00500 OUTSTR[ASCIZ/ K = /]
00600 CALL(REALIN)
00700 DAC K1↔DAC K2
00750
00800 LAC[1.0]
00900 LAC SLANT,CTRL↔AND SLANT,META
00950 SKIPE SLANT↔SETZM META
01000 SKIPE CTRL↔DAC K2
01100 SKIPE META↔DAC K1
01200
01300 SKIPN 1,FILM↔POP0J
01400 SON IMG,1↔SKIPN IMG↔POP0J
01500 DAC IMG,IMG0# ;FIRST IMAGE OF FILM
01600 L2: SON LVL,IMG
01700 SON PGN,LVL↔DAC PGN,PGN0# ;FIRST POLYGON OF IMAGE.
01800
01900 L5: SON V,PGN↔DAC V,V0#
02000 L6: ROW R,V↔FLO R,↔MOVNS R↔FAD R,[108.0]↔FMP R,K1
02100 COL C,V↔FLO C,↔FSB C,[144.0]↔FMP C,K2
02200 JUMPN SLANT,[FADR C,R↔GO L7]
02300 LAC[108.0]↔FSB R↔FIX 225000↔ROW. 0,V
02400 L7: FAD C,[144.0]↔FIX C,225000↔COL. C,V
02500 CCW V,V↔CAME V,V0↔GO L6
02600 CCW PGN,PGN↔CAME PGN,PGN0↔GO L5
02700 ;NEXT IMAGE.
02800 CCW IMG,IMG↔CAME IMG,IMG0↔GO L2
02900 CALL(DPYIMG)
03000 POP0J
03100 BEND;1/28/73------------------------------------------------------